home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2007 September / PCWSEP07.iso / Software / Linux / Linux Mint 3.0 Light / LinuxMint-3.0-Light.iso / casper / filesystem.squashfs / usr / share / intltool-debian / intltool-extract next >
Encoding:
Text File  |  2006-11-08  |  26.0 KB  |  951 lines
  1. #!/usr/bin/perl -w 
  2. # -*- Mode: perl; indent-tabs-mode: nil; c-basic-offset: 4  -*-
  3.  
  4. #
  5. #  The Intltool Message Extractor
  6. #
  7. #  Copyright (C) 2000-2001, 2003 Free Software Foundation.
  8. #
  9. #  Intltool is free software; you can redistribute it and/or
  10. #  modify it under the terms of the GNU General Public License as
  11. #  published by the Free Software Foundation; either version 2 of the
  12. #  License, or (at your option) any later version.
  13. #
  14. #  Intltool is distributed in the hope that it will be useful,
  15. #  but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17. #  General Public License for more details.
  18. #
  19. #  You should have received a copy of the GNU General Public License
  20. #  along with this program; if not, write to the Free Software
  21. #  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22. #
  23. #  As a special exception to the GNU General Public License, if you
  24. #  distribute this file as part of a program that contains a
  25. #  configuration script generated by Autoconf, you may include it under
  26. #  the same distribution terms that you use for the rest of that program.
  27. #
  28. #  Authors: Kenneth Christiansen <kenneth@gnu.org>
  29. #           Darin Adler <darin@bentspoon.com>
  30. #
  31.  
  32. ## Release information
  33. my $PROGRAM      = "intltool-extract";
  34. my $PACKAGE      = "intltool";
  35. my $VERSION      = "0.35.0";
  36.  
  37. ## Loaded modules
  38. use strict; 
  39. use File::Basename;
  40. use Getopt::Long;
  41.  
  42. ## Scalars used by the option stuff
  43. my $TYPE_ARG    = "0";
  44. my $LOCAL_ARG    = "0";
  45. my $HELP_ARG     = "0";
  46. my $VERSION_ARG = "0";
  47. my $UPDATE_ARG  = "0";
  48. my $QUIET_ARG   = "0";
  49. my $SRCDIR_ARG    = ".";
  50.  
  51. my $FILE;
  52. my $OUTFILE;
  53.  
  54. my $gettext_type = "";
  55. my $input;
  56. my %messages = ();
  57. my %loc = ();
  58. my %count = ();
  59. my %comments = ();
  60. my $strcount = 0;
  61.  
  62. my $XMLCOMMENT = "";
  63.  
  64. ## Use this instead of \w for XML files to handle more possible characters.
  65. my $w = "[-A-Za-z0-9._:]";
  66.  
  67. ## Always print first
  68. $| = 1;
  69.  
  70. ## Handle options
  71. GetOptions (
  72.         "type=s"     => \$TYPE_ARG,
  73.             "local|l"    => \$LOCAL_ARG,
  74.             "help|h"     => \$HELP_ARG,
  75.             "version|v"  => \$VERSION_ARG,
  76.             "update"     => \$UPDATE_ARG,
  77.         "quiet|q"    => \$QUIET_ARG,
  78.         "srcdir=s"     => \$SRCDIR_ARG,
  79.             ) or &error;
  80.  
  81. &split_on_argument;
  82.  
  83.  
  84. ## Check for options. 
  85. ## This section will check for the different options.
  86.  
  87. sub split_on_argument {
  88.  
  89.     if ($VERSION_ARG) {
  90.         &version;
  91.  
  92.     } elsif ($HELP_ARG) {
  93.     &help;
  94.         
  95.     } elsif ($LOCAL_ARG) {
  96.         &place_local;
  97.         &extract;
  98.  
  99.     } elsif ($UPDATE_ARG) {
  100.     &place_normal;
  101.     &extract;
  102.  
  103.     } elsif (@ARGV > 0) {
  104.     &place_normal;
  105.     &message;
  106.     &extract;
  107.  
  108.     } else {
  109.     &help;
  110.  
  111.     }  
  112. }    
  113.  
  114. sub place_normal {
  115.     $FILE     = $ARGV[0];
  116.     $OUTFILE     = "$FILE.h";
  117. }   
  118.  
  119. sub place_local {
  120.     $FILE     = $ARGV[0];
  121.     $OUTFILE     = fileparse($FILE, ());
  122.     if (!-e "tmp/") { 
  123.         system("mkdir tmp/"); 
  124.     }
  125.     $OUTFILE     = "./tmp/$OUTFILE.h"
  126. }
  127.  
  128. sub determine_type {
  129.    if ($TYPE_ARG =~ /^gettext\/(.*)/) {
  130.     $gettext_type=$1
  131.    }
  132. }
  133.  
  134. ## Sub for printing release information
  135. sub version{
  136.     print <<_EOF_;
  137. ${PROGRAM} (${PACKAGE}) $VERSION
  138. Copyright (C) 2000, 2003 Free Software Foundation, Inc.
  139. Written by Kenneth Christiansen, 2000.
  140.  
  141. This is free software; see the source for copying conditions.  There is NO
  142. warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  143. _EOF_
  144.     exit;
  145. }
  146.  
  147. ## Sub for printing usage information
  148. sub help {
  149.     print <<_EOF_;
  150. Usage: ${PROGRAM} [OPTION]... [FILENAME]
  151. Generates a header file from an XML source file.
  152.  
  153. It grabs all strings between <_translatable_node> and its end tag in
  154. XML files. Read manpage (man ${PROGRAM}) for more info.
  155.  
  156.       --type=TYPE   Specify the file type of FILENAME. Currently supports:
  157.                     "gettext/glade", "gettext/ini", "gettext/keys"
  158.                     "gettext/rfc822deb", "gettext/schemas",
  159.                     "gettext/scheme", "gettext/xml", "gettext/quoted"
  160.   -l, --local       Writes output into current working directory
  161.                     (conflicts with --update)
  162.       --update      Writes output into the same directory the source file 
  163.                     reside (conflicts with --local)
  164.       --srcdir      Root of the source tree
  165.   -v, --version     Output version information and exit
  166.   -h, --help        Display this help and exit
  167.   -q, --quiet       Quiet mode
  168.  
  169. Report bugs to http://bugzilla.gnome.org/ (product name "$PACKAGE")
  170. or send email to <xml-i18n-tools\@gnome.org>.
  171. _EOF_
  172.     exit;
  173. }
  174.  
  175. ## Sub for printing error messages
  176. sub error{
  177.     print STDERR "Try `${PROGRAM} --help' for more information.\n";
  178.     exit;
  179. }
  180.  
  181. sub message {
  182.     print "Generating C format header file for translation.\n" unless $QUIET_ARG;
  183. }
  184.  
  185. sub extract {
  186.     &determine_type;
  187.  
  188.     &convert;
  189.  
  190.     open OUT, ">$OUTFILE";
  191.     binmode (OUT) if $^O eq 'MSWin32';
  192.     &msg_write;
  193.     close OUT;
  194.  
  195.     print "Wrote $OUTFILE\n" unless $QUIET_ARG;
  196. }
  197.  
  198. sub convert {
  199.  
  200.     ## Reading the file
  201.     {
  202.     local (*IN);
  203.     local $/; #slurp mode
  204.     open (IN, "<$SRCDIR_ARG/$FILE") || die "can't open $SRCDIR_ARG/$FILE: $!";
  205.     $input = <IN>;
  206.     }
  207.  
  208.     &type_ini if $gettext_type eq "ini";
  209.     &type_keys if $gettext_type eq "keys";
  210.     &type_xml if $gettext_type eq "xml";
  211.     &type_glade if $gettext_type eq "glade";
  212.     &type_scheme if $gettext_type eq "scheme";
  213.     &type_schemas  if $gettext_type eq "schemas";
  214.     &type_rfc822deb  if $gettext_type eq "rfc822deb";
  215.     &type_quoted if $gettext_type eq "quoted";
  216. }
  217.  
  218. sub entity_decode_minimal
  219. {
  220.     local ($_) = @_;
  221.  
  222.     s/'/'/g; # '
  223.     s/"/"/g; # "
  224.     s/&/&/g;
  225.  
  226.     return $_;
  227. }
  228.  
  229. sub entity_decode
  230. {
  231.     local ($_) = @_;
  232.  
  233.     s/'/'/g; # '
  234.     s/"/"/g; # "
  235.     s/&/&/g;
  236.     s/</</g;
  237.     s/>/>/g;
  238.  
  239.     return $_;
  240. }
  241.  
  242. sub escape_char
  243. {
  244.     return '\"' if $_ eq '"';
  245.     return '\n' if $_ eq "\n";
  246.     return '\\\\' if $_ eq '\\';
  247.  
  248.     return $_;
  249. }
  250.  
  251. sub escape
  252. {
  253.     my ($string) = @_;
  254.     return join "", map &escape_char, split //, $string;
  255. }
  256.  
  257. sub type_ini {
  258.     ### For generic translatable desktop files ###
  259.     while ($input =~ /^_.*=(.*)$/mg) {
  260.         $messages{$1} = [];
  261.     }
  262. }
  263.  
  264. sub type_keys {
  265.     ### For generic translatable mime/keys files ###
  266.     while ($input =~ /^\s*_\w+=(.*)$/mg) {
  267.         $messages{$1} = [];
  268.     }
  269. }
  270.  
  271. sub type_xml {
  272.     ### For generic translatable XML files ###
  273.     my $tree = readXml($input);
  274.     parseTree(0, $tree);
  275. }
  276.  
  277. sub print_var {
  278.     my $var = shift;
  279.     my $vartype = ref $var;
  280.     
  281.     if ($vartype =~ /ARRAY/) {
  282.         my @arr = @{$var};
  283.         print "[ ";
  284.         foreach my $el (@arr) {
  285.             print_var($el);
  286.             print ", ";
  287.         }
  288.         print "] ";
  289.     } elsif ($vartype =~ /HASH/) {
  290.         my %hash = %{$var};
  291.         print "{ ";
  292.         foreach my $key (keys %hash) {
  293.             print "$key => ";
  294.             print_var($hash{$key});
  295.             print ", ";
  296.         }
  297.         print "} ";
  298.     } else {
  299.         print $var;
  300.     }
  301. }
  302.  
  303. # Same syntax as getAttributeString in intltool-merge.in.in, similar logic (look for ## differences comment)
  304. sub getAttributeString
  305. {
  306.     my $sub = shift;
  307.     my $do_translate = shift || 1;
  308.     my $language = shift || "";
  309.     my $translate = shift;
  310.     my $result = "";
  311.     foreach my $e (reverse(sort(keys %{ $sub }))) {
  312.     my $key    = $e;
  313.     my $string = $sub->{$e};
  314.     my $quote = '"';
  315.     
  316.     $string =~ s/^[\s]+//;
  317.     $string =~ s/[\s]+$//;
  318.     
  319.     if ($string =~ /^'.*'$/)
  320.     {
  321.         $quote = "'";
  322.     }
  323.     $string =~ s/^['"]//g;
  324.     $string =~ s/['"]$//g;
  325.  
  326.         ## differences from intltool-merge.in.in
  327.     if ($key =~ /^_/) {
  328.             $comments{entity_decode($string)} = $XMLCOMMENT if $XMLCOMMENT;
  329.             $messages{entity_decode($string)} = [];
  330.             $$translate = 2;
  331.     }
  332.         ## differences end here from intltool-merge.in.in
  333.     $result .= " $key=$quote$string$quote";
  334.     }
  335.     return $result;
  336. }
  337.  
  338. # Verbatim copy from intltool-merge.in.in
  339. sub getXMLstring
  340. {
  341.     my $ref = shift;
  342.     my $spacepreserve = shift || 0;
  343.     my @list = @{ $ref };
  344.     my $result = "";
  345.  
  346.     my $count = scalar(@list);
  347.     my $attrs = $list[0];
  348.     my $index = 1;
  349.  
  350.     $spacepreserve = 1 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/));
  351.     $spacepreserve = 0 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?default["']?$/));
  352.  
  353.     while ($index < $count) {
  354.     my $type = $list[$index];
  355.     my $content = $list[$index+1];
  356.         if (! $type ) {
  357.         # We've got CDATA
  358.         if ($content) {
  359.         # lets strip the whitespace here, and *ONLY* here
  360.                 $content =~ s/\s+/ /gs if (!$spacepreserve);
  361.         $result .= $content;
  362.         }
  363.     } elsif ( "$type" ne "1" ) {
  364.         # We've got another element
  365.         $result .= "<$type";
  366.         $result .= getAttributeString(@{$content}[0], 0); # no nested translatable elements
  367.         if ($content) {
  368.         my $subresult = getXMLstring($content, $spacepreserve);
  369.         if ($subresult) {
  370.             $result .= ">".$subresult . "</$type>";
  371.         } else {
  372.             $result .= "/>";
  373.         }
  374.         } else {
  375.         $result .= "/>";
  376.         }
  377.     }
  378.     $index += 2;
  379.     }
  380.     return $result;
  381. }
  382.  
  383. # Verbatim copy from intltool-merge.in.in, except for MULTIPLE_OUTPUT handling removed
  384. # Translate list of nodes if necessary
  385. sub translate_subnodes
  386. {
  387.     my $fh = shift;
  388.     my $content = shift;
  389.     my $language = shift || "";
  390.     my $singlelang = shift || 0;
  391.     my $spacepreserve = shift || 0;
  392.  
  393.     my @nodes = @{ $content };
  394.  
  395.     my $count = scalar(@nodes);
  396.     my $index = 0;
  397.     while ($index < $count) {
  398.         my $type = $nodes[$index];
  399.         my $rest = $nodes[$index+1];
  400.         traverse($fh, $type, $rest, $language, $spacepreserve);
  401.         $index += 2;
  402.     }
  403. }
  404.  
  405. # Based on traverse() in intltool-merge.in.in
  406. sub traverse
  407. {
  408.     my $fh = shift; # unused, to allow us to sync code between -merge and -extract
  409.     my $nodename = shift;
  410.     my $content = shift;
  411.     my $language = shift || "";
  412.     my $spacepreserve = shift || 0;
  413.  
  414.     if ($nodename && "$nodename" eq "1") {
  415.         $XMLCOMMENT = $content;
  416.     } elsif ($nodename) {
  417.     # element
  418.     my @all = @{ $content };
  419.     my $attrs = shift @all;
  420.     my $translate = 0;
  421.     my $outattr = getAttributeString($attrs, 1, $language, \$translate);
  422.  
  423.     if ($nodename =~ /^_/) {
  424.         $translate = 1;
  425.         $nodename =~ s/^_//;
  426.     }
  427.     my $lookup = '';
  428.  
  429.         $spacepreserve = 0 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?default["']?$/));
  430.         $spacepreserve = 1 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/));
  431.  
  432.     if ($translate) {
  433.         $lookup = getXMLstring($content, $spacepreserve);
  434.             if (!$spacepreserve) {
  435.                 $lookup =~ s/^\s+//s;
  436.                 $lookup =~ s/\s+$//s;
  437.             }
  438.  
  439.         if ($lookup && $translate != 2) {
  440.                 $comments{$lookup} = $XMLCOMMENT if $XMLCOMMENT;
  441.                 $messages{$lookup} = [];
  442.             } elsif ($translate == 2) {
  443.                 translate_subnodes($fh, \@all, $language, 1, $spacepreserve);
  444.         }
  445.     } else {
  446.             $XMLCOMMENT = "";
  447.         my $count = scalar(@all);
  448.         if ($count > 0) {
  449.                 my $index = 0;
  450.                 while ($index < $count) {
  451.                     my $type = $all[$index];
  452.                     my $rest = $all[$index+1];
  453.                     traverse($fh, $type, $rest, $language, $spacepreserve);
  454.                     $index += 2;
  455.                 }
  456.         }
  457.     }
  458.         $XMLCOMMENT = "";
  459.     }
  460. }
  461.  
  462.  
  463. # Verbatim copy from intltool-merge.in.in, $fh for compatibility
  464. sub parseTree
  465. {
  466.     my $fh        = shift;
  467.     my $ref       = shift;
  468.     my $language  = shift || "";
  469.  
  470.     my $name = shift @{ $ref };
  471.     my $cont = shift @{ $ref };
  472.  
  473.     while (!$name || "$name" eq "1") {
  474.         $name = shift @{ $ref };
  475.         $cont = shift @{ $ref };
  476.     }
  477.  
  478.     my $spacepreserve = 0;
  479.     my $attrs = @{$cont}[0];
  480.     $spacepreserve = 1 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/));
  481.  
  482.     traverse($fh, $name, $cont, $language, $spacepreserve);
  483. }
  484.  
  485. # Verbatim copy from intltool-merge.in.in
  486. sub intltool_tree_comment
  487. {
  488.     my $expat = shift;
  489.     my $data  = $expat->original_string();
  490.     my $clist = $expat->{Curlist};
  491.     my $pos   = $#$clist;
  492.  
  493.     $data =~ s/^<!--//s;
  494.     $data =~ s/-->$//s;
  495.     push @$clist, 1 => $data;
  496. }
  497.  
  498. # Verbatim copy from intltool-merge.in.in
  499. sub intltool_tree_cdatastart
  500. {
  501.     my $expat    = shift;
  502.     my $clist = $expat->{Curlist};
  503.     my $pos   = $#$clist;
  504.  
  505.     push @$clist, 0 => $expat->original_string();
  506. }
  507.  
  508. # Verbatim copy from intltool-merge.in.in
  509. sub intltool_tree_cdataend
  510. {
  511.     my $expat    = shift;
  512.     my $clist = $expat->{Curlist};
  513.     my $pos   = $#$clist;
  514.  
  515.     $clist->[$pos] .= $expat->original_string();
  516. }
  517.  
  518. # Verbatim copy from intltool-merge.in.in
  519. sub intltool_tree_char
  520. {
  521.     my $expat = shift;
  522.     my $text  = shift;
  523.     my $clist = $expat->{Curlist};
  524.     my $pos   = $#$clist;
  525.  
  526.     # Use original_string so that we retain escaped entities
  527.     # in CDATA sections.
  528.     #
  529.     if ($pos > 0 and $clist->[$pos - 1] eq '0') {
  530.         $clist->[$pos] .= $expat->original_string();
  531.     } else {
  532.         push @$clist, 0 => $expat->original_string();
  533.     }
  534. }
  535.  
  536. # Verbatim copy from intltool-merge.in.in
  537. sub intltool_tree_start
  538. {
  539.     my $expat    = shift;
  540.     my $tag      = shift;
  541.     my @origlist = ();
  542.  
  543.     # Use original_string so that we retain escaped entities
  544.     # in attribute values.  We must convert the string to an
  545.     # @origlist array to conform to the structure of the Tree
  546.     # Style.
  547.     #
  548.     my @original_array = split /\x/, $expat->original_string();
  549.     my $source         = $expat->original_string();
  550.  
  551.     # Remove leading tag.
  552.     #
  553.     $source =~ s|^\s*<\s*(\S+)||s;
  554.  
  555.     # Grab attribute key/value pairs and push onto @origlist array.
  556.     #
  557.     while ($source)
  558.     {
  559.        if ($source =~ /^\s*([\w:-]+)\s*[=]\s*["]/)
  560.        {
  561.            $source =~ s|^\s*([\w:-]+)\s*[=]\s*["]([^"]*)["]||s;
  562.            push @origlist, $1;
  563.            push @origlist, '"' . $2 . '"';
  564.        }
  565.        elsif ($source =~ /^\s*([\w:-]+)\s*[=]\s*[']/)
  566.        {
  567.            $source =~ s|^\s*([\w:-]+)\s*[=]\s*[']([^']*)[']||s;
  568.            push @origlist, $1;
  569.            push @origlist, "'" . $2 . "'";
  570.        }
  571.        else
  572.        {
  573.            last;
  574.        }
  575.     }
  576.  
  577.     my $ol = [ { @origlist } ];
  578.  
  579.     push @{ $expat->{Lists} }, $expat->{Curlist};
  580.     push @{ $expat->{Curlist} }, $tag => $ol;
  581.     $expat->{Curlist} = $ol;
  582. }
  583.  
  584. # Copied from intltool-merge.in.in and added comment handler.
  585. sub readXml
  586. {
  587.     my $xmldoc = shift || return;
  588.     my $ret = eval 'require XML::Parser';
  589.     if(!$ret) {
  590.         die "You must have XML::Parser installed to run $0\n\n";
  591.     }
  592.     my $xp = new XML::Parser(Style => 'Tree');
  593.     $xp->setHandlers(Char => \&intltool_tree_char);
  594.     $xp->setHandlers(Start => \&intltool_tree_start);
  595.     $xp->setHandlers(CdataStart => \&intltool_tree_cdatastart);
  596.     $xp->setHandlers(CdataEnd => \&intltool_tree_cdataend);
  597.  
  598.     ## differences from intltool-merge.in.in
  599.     $xp->setHandlers(Comment => \&intltool_tree_comment);
  600.     ## differences end here from intltool-merge.in.in
  601.  
  602.     my $tree = $xp->parse($xmldoc);
  603.     #print_var($tree);
  604.  
  605. # <foo><!-- comment --><head id="a">Hello <em>there</em></head><bar>Howdy<ref/></bar>do</foo>
  606. # would be:
  607. # [foo, [{}, 1, "comment", head, [{id => "a"}, 0, "Hello ",  em, [{}, 0, "there"]], bar, 
  608. # [{}, 0, "Howdy",  ref, [{}]], 0, "do" ] ]
  609.  
  610.     return $tree;
  611. }
  612.  
  613. sub type_schemas {
  614.     ### For schemas XML files ###
  615.          
  616.     # FIXME: We should handle escaped < (less than)
  617.     while ($input =~ /
  618.                       <locale\ name="C">\s*
  619.                           (<default>\s*(?:<!--([^>]*?)-->\s*)?(.*?)\s*<\/default>\s*)?
  620.                           (<short>\s*(?:<!--([^>]*?)-->\s*)?(.*?)\s*<\/short>\s*)?
  621.                           (<long>\s*(?:<!--([^>]*?)-->\s*)?(.*?)\s*<\/long>\s*)?
  622.                       <\/locale>
  623.                      /sgx) {
  624.         my @totranslate = ($3,$6,$9);
  625.         my @eachcomment = ($2,$5,$8);
  626.         foreach (@totranslate) {
  627.             my $currentcomment = shift @eachcomment;
  628.             next if !$_;
  629.             s/\s+/ /g;
  630.             $messages{entity_decode_minimal($_)} = [];
  631.             $comments{entity_decode_minimal($_)} = $currentcomment if (defined($currentcomment));
  632.         }
  633.     }
  634. }
  635.  
  636. sub type_rfc822deb {
  637.     ### For rfc822-style Debian configuration files ###
  638.  
  639.     my $templateNr = 1001;
  640.     my $type = '';
  641.     while ($input =~ /\G(.*?)(^|\n)(_+)([^:\s]+)(:[ \t]*)(.*?)(?=\n[\S\n]|$)/sg)
  642.     {
  643.         my ($pre, $newline, $underscore, $tag, $space, $text) = ($1, $2, $3, $4, $5, $6);
  644.         if ($pre =~ m/\n\n/) {
  645.             while ($pre =~ m/\n\n/g)
  646.             {
  647.                 $templateNr += 1000;
  648.             }
  649.             $templateNr = sprintf("%d", $templateNr / 1000) * 1000 + 1;
  650.         }
  651.         my @str_list = rfc822deb_split(length($underscore), $text);
  652.         #   Dirty hack for po-debconf until a better solution is found.
  653.         if (defined($ENV{INTLTOOL_DEBIAN_TYPE}) && $ENV{INTLTOOL_DEBIAN_TYPE} eq 'po-debconf') {
  654.                 while($pre =~ m/^(Type:\s*\S+)/mig)
  655.                 {
  656.                         #  This variable has to be persistent because several
  657.                         #  fields may be translated in a single template
  658.                         $type = $1;
  659.                 }
  660.                 $tag = $type . "\n" . $tag if length($type);
  661.         }
  662.         #  Process pseudo-comments
  663.         my $usercomment = '';
  664.         while($pre =~ s/(^|\n)#(.*)$//)
  665.         {
  666.             $usercomment = "\n" . $2 . $usercomment;
  667.         }
  668.         my @tfields = ();
  669.         my @pocomments = ();
  670.         if ($usercomment =~ m/^flag:/m)
  671.         {
  672.             #  There is an implicit #flag:comment:* if comments are found before
  673.             #  any directive.
  674.             $usercomment = "\nflag:comment:*".$usercomment
  675.                 unless $usercomment =~ m/^\nflag:/s;
  676.             my @c = split (/\nflag:/, $usercomment);
  677.             #  The first field may be null
  678.             shift (@c) if ($c[0] =~ m/^\s*$/s);
  679.             for (@c)
  680.             {
  681.                 if (s/^comment(!?):(\S+)(?=\n|$)//s)
  682.                 {
  683.                     rfc822deb_parse_spec($2, $1, 1+$#str_list, '', $_, \@pocomments);
  684.                 }
  685.                 elsif (s/^translate(!?):(\S+)(?=\n|$)//s)
  686.                 {
  687.                     rfc822deb_parse_spec($2, $1, 1+$#str_list, 0, 1, \@tfields);
  688.                 }
  689.                 elsif (s/^partial(?=\n|$)//s)
  690.                 {
  691.                     # This command is ignored by intltool-extract
  692.                 }
  693.                 else
  694.                 {
  695.                     die "Unknown directive: $_\n\nAborting!\n";
  696.                 }
  697.             }
  698.             $usercomment =~ s/(^|\n)flag:[^\n]*(\n|$)//sg;
  699.             $usercomment = "\n".$usercomment
  700.                 if ($usercomment !~ m/^\n/s && $usercomment =~ m/\S/);
  701.         }
  702.         #  By default, print all msgids
  703.         rfc822deb_parse_spec('*', '', 1+$#str_list, 0, 1, \@tfields)
  704.             if $#tfields == -1;
  705.         #  By default, print comments before all msgids
  706.         rfc822deb_parse_spec('*', '', 1+$#str_list, '', $usercomment, \@pocomments)
  707.             if $#pocomments == -1;
  708.         my $cnt = 0;
  709.         for my $str (@str_list)
  710.         {
  711.             $cnt++;
  712.             $strcount++;
  713.             next if (exists($tfields[$cnt]) && $tfields[$cnt] != 1);
  714.             $messages{$str} = [];
  715.             $count{$str} = $strcount unless defined $count{$str};
  716.             if (defined $comments{$str}) {
  717.                 $comments{$str} .= "\n";
  718.             } else {
  719.                 $comments{$str} = "";
  720.             }
  721.             $comments{$str} .= $tag . $pocomments[$cnt];
  722.             $comments{$str} .= "\nxgettext:no-c-format" if $str =~ /%/;
  723.             push (@{$loc{$str}}, $templateNr);
  724.         }
  725.         $templateNr++;
  726.     }
  727.     # Note: this adjustment for $offsetlines is not mandatory within
  728.     # type_rfc822deb but is kept here as an example for other types,
  729.     # if original line numbers are to be preserved.
  730.     while (my ($str, $comm) = each %comments) {
  731.             my $temp = $comm;
  732.             my $offsetlines = 1 + ($temp =~ s/\n//g);
  733.             map { $_ -= $offsetlines } @{$loc{$str}};
  734.     }
  735. }
  736.  
  737. sub rfc822deb_parse_spec {
  738.     my $spec = shift;
  739.     my $negate = shift;
  740.     my $len = shift;
  741.     my $notfound = shift;
  742.     my $found = shift;
  743.     my $ref = shift;
  744.     $spec = ','.$spec.',';
  745.     #  Replace '*' by all values
  746.     my $all = '1-'.$len;
  747.     $spec =~ s/\*/$all/g;
  748.     #  Expand ranges
  749.     $spec =~ s/(\d+)-(\d+)/join(",", ($1..$2))/eg;
  750.     if ($#{$ref} == -1)
  751.     {
  752.         push (@{$ref}, $notfound);
  753.         for my $cnt (1..$len)
  754.         {
  755.             $ref->[$cnt] = $notfound;
  756.         }
  757.     }
  758.     for my $cnt (1..$len)
  759.     {
  760.         if ($spec =~ m/,$cnt,/ && !$negate) {
  761.             $ref->[$cnt] .= $found;
  762.         } elsif ($spec !~ m/,$cnt,/ && $negate) {
  763.             $ref->[$cnt] .= $found;
  764.         }
  765.     }
  766. }
  767.  
  768. sub rfc822deb_split {
  769.     # Debian defines a special way to deal with rfc822-style files:
  770.     # when a value contain newlines, it consists of
  771.     #   1.  a short form (first line)
  772.     #   2.  a long description, all lines begin with a space,
  773.     #       and paragraphs are separated by a single dot on a line
  774.     # This routine returns an array of all paragraphs, and reformat
  775.     # them.
  776.     # When first argument is 2, the string is a comma separated list of
  777.     # values.
  778.     my $type = shift;
  779.     my $text = shift;
  780.     $text =~ s/^[ \t]//mg;
  781.     if ($type ne 1)
  782.     {
  783.         my @values = ();
  784.         for my $value (split(/(?<!\\), */, $text, 0))
  785.         {
  786.             $value =~ s/\\,/,/g;
  787.             push @values, $value;
  788.         }
  789.         return @values;
  790.     }
  791.     return ($text) if $text !~ /\n/;
  792.  
  793.     $text =~ s/([^\n]*)\n//;
  794.     my @list = ($1);
  795.     my $str = '';
  796.     for my $line (split (/\n/, $text))
  797.     {
  798.         chomp $line;
  799.         if ($line =~ /^\.\s*$/)
  800.         {
  801.             #  New paragraph
  802.             $str =~ s/\s*$//;
  803.             push(@list, $str);
  804.             $str = '';
  805.         }
  806.         elsif ($line =~ /^\s/)
  807.         {
  808.             #  Line which must not be reformatted
  809.             $str .= "\n" if length ($str) && $str !~ /\n$/;
  810.             $line =~ s/\s+$//;
  811.             $str .= $line."\n";
  812.         }
  813.         else
  814.         {
  815.             #  Continuation line, remove newline
  816.             $str .= " " if length ($str) && $str !~ /\n$/;
  817.             $str .= $line;
  818.         }
  819.     }
  820.     $str =~ s/\s*$//;
  821.     push(@list, $str) if length ($str);
  822.     return @list;
  823. }
  824.  
  825. sub type_quoted {
  826.     while ($input =~ /\"(([^\"]|\\\")*[^\\\"])\"/g) {
  827.         my $message = $1;
  828.         my $before = $`;
  829.         $message =~ s/\\\"/\"/g;
  830.         $before =~ s/[^\n]//g;
  831.         $messages{$message} = [];
  832.         $loc{$message} = length ($before) + 2;
  833.     }
  834. }
  835.  
  836. sub type_glade {
  837.     ### For translatable Glade XML files ###
  838.  
  839.     my $tags = "label|title|text|format|copyright|comments|preview_text|tooltip|message";
  840.  
  841.     while ($input =~ /<($tags)>([^<]+)<\/($tags)>/sg) {
  842.     # Glade sometimes uses tags that normally mark translatable things for
  843.         # little bits of non-translatable content. We work around this by not
  844.         # translating strings that only includes something like label4 or window1.
  845.     $messages{entity_decode($2)} = [] unless $2 =~ /^(window|label|dialog)[0-9]+$/;
  846.     }
  847.     
  848.     while ($input =~ /<items>(..[^<]*)<\/items>/sg) {
  849.     for my $item (split (/\n/, $1)) {
  850.         $messages{entity_decode($item)} = [];
  851.     }
  852.     }
  853.  
  854.     ## handle new glade files
  855.     while ($input =~ /<(property|atkproperty)\s+[^>]*translatable\s*=\s*"yes"(?:\s+[^>]*comments\s*=\s*"([^"]*)")?[^>]*>([^<]+)<\/\1>/sg) {
  856.     $messages{entity_decode($3)} = [] unless $3 =~ /^(window|label)[0-9]+$/;
  857.         if (defined($2) and !($3 =~ /^(window|label)[0-9]+$/)) {
  858.        $comments{entity_decode($3)} = entity_decode($2) ;
  859.         }
  860.     }
  861.     while ($input =~ /<atkaction\s+action_name="([^>]*)"\s+description="([^>]+)"\/>/sg) {
  862.         $messages{entity_decode_minimal($2)} = [];
  863.     }
  864. }
  865.  
  866. sub type_scheme {
  867.     my ($line, $i, $state, $str, $trcomment, $char);
  868.     for $line (split(/\n/, $input)) {
  869.         $i = 0;
  870.         $state = 0; # 0 - nothing, 1 - string, 2 - translatable string
  871.         while ($i < length($line)) {
  872.             if (substr($line,$i,1) eq "\"") {
  873.                 if ($state == 2) {
  874.                     $comments{$str} = $trcomment if ($trcomment);
  875.                     $messages{$str} = [];
  876.                     $str = '';
  877.                     $state = 0; $trcomment = "";
  878.                 } elsif ($state == 1) {
  879.                     $str = '';
  880.                     $state = 0; $trcomment = "";
  881.                 } else {
  882.                     $state = 1;
  883.                     $str = '';
  884.                     if ($i>0 && substr($line,$i-1,1) eq '_') {
  885.                         $state = 2;
  886.                     }
  887.                 }
  888.             } elsif (!$state) {
  889.                 if (substr($line,$i,1) eq ";") {
  890.                     $trcomment = substr($line,$i+1);
  891.                     $trcomment =~ s/^;*\s*//;
  892.                     $i = length($line);
  893.                 } elsif ($trcomment && substr($line,$i,1) !~ /\s|\(|\)|_/) {
  894.                     $trcomment = "";
  895.                 }
  896.             } else {
  897.                 if (substr($line,$i,1) eq "\\") {
  898.                     $char = substr($line,$i+1,1);
  899.                     if ($char ne "\"" && $char ne "\\") {
  900.                        $str = $str . "\\";
  901.                     }
  902.                     $i++;
  903.                 }
  904.                 $str = $str . substr($line,$i,1);
  905.             }
  906.             $i++;
  907.         }
  908.     }
  909. }
  910.  
  911. sub msg_write {
  912.     for my $msg (keys %comments) {
  913.         $comments{$msg} =~ s,^,// ,mg;
  914.         $comments{$msg} .= "\n";
  915.     }
  916.     my @msgids;
  917.     if (%count)
  918.     {
  919.         @msgids = sort { $count{$a} <=> $count{$b} } keys %count;
  920.     }
  921.     else
  922.     {
  923.         @msgids = sort keys %messages;
  924.     }
  925.     for my $message (@msgids)
  926.     {
  927.         my $text = "";
  928.         $text .= $comments{$message}
  929.             if defined $comments{$message};
  930.         
  931.         my @lines = split (/\n/, $message, -1);
  932.         for (my $n = 0; $n < @lines; $n++)
  933.         {
  934.             $text .= $n == 0 ?
  935.                 "char *s = N_(\"" :
  936.                 "             \""; 
  937.             $text .= escape($lines[$n]);
  938.             $text .= $n < @lines - 1 ?  "\\n\"\n" : "\");\n";  
  939.         }
  940.         if (defined $loc{$message})
  941.         {
  942.             map {print OUT "# ".$_." \"$FILE\"\n$text"} @{$loc{$message}};
  943.         }
  944.         else
  945.         {
  946.             print OUT $text;
  947.         }
  948.     }
  949. }
  950.  
  951.